home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 1463.ZIP / DRAW-2D.ARC / SELAREA.PAS < prev    next >
Pascal/Delphi Source File  |  1986-12-03  |  4KB  |  106 lines
  1. PROCEDURE SELAREA(VAR KODE:INTEGER);
  2.    VAR
  3.      X4,Y4:REAL;
  4.      T,XS,XB,YS,YB:REAL;
  5.      FLAG:BOOLEAN;
  6.      K:INTEGER;
  7.    BEGIN
  8.      KODE := 1;
  9.      MOVCUR(24,2);
  10.      WRITE('Select Corner of Area & press Left button >');
  11.      RING(1);
  12.      FLAG := FALSE;
  13.      WHILE NOT(FLAG) DO
  14.        BEGIN
  15.         GETMOUSE(X,Y,PIXX,PIXY,OPTION);
  16.         IF BUTTON1 THEN FLAG := TRUE;
  17.         IF (BUTTON1) AND (OPTION <> 0) THEN
  18.            BEGIN
  19.              FLAG := FALSE;
  20.              RING2;
  21.              MOVCUR(24,1);
  22.              WRITE(BLKLINE);
  23.              MOVCUR(24,2);
  24.              WRITE('Move mouse cursor into graphics area!!');
  25.            END;
  26.         IF BUTTON2 THEN RING2;
  27.        END;
  28.      M1 := 2;
  29.      MOUSE(M1,M2,M3,M4);          (* HIDE MOUSE *)
  30.      MARK(PIXX,PIXY,HRCOLOR);
  31.      M1 := 1;                     (* SHOW MOUSE *)
  32.      MOUSE(M1,M2,M3,M4);
  33.      XS := X;
  34.      YS := Y;
  35.      MOVCUR(24,1);
  36.      WRITE(BLKLINE);
  37.      MOVCUR(24,2);
  38.      WRITE('Select 2nd Corner & press Left button (Right button to Cancel) >');
  39.      RING(1);
  40.      FLAG := FALSE;
  41.      WHILE NOT(FLAG) DO
  42.         BEGIN
  43.           GETMOUSE(X,Y,PIXX,PIXY,OPTION);
  44.           IF (BUTTON1) OR (BUTTON2) THEN FLAG := TRUE;
  45.           IF (BUTTON1) AND (OPTION <> 0) THEN
  46.            BEGIN
  47.              FLAG := FALSE;
  48.              RING2;
  49.              MOVCUR(24,1);
  50.              WRITE(BLKLINE);
  51.              MOVCUR(24,2);
  52.              WRITE('Move mouse cursor into graphics area!!');
  53.            END;
  54.         END;
  55.      MOVCUR(24,1);
  56.      WRITE(BLKLINE);
  57.      IF BUTTON1 THEN
  58.         BEGIN
  59.           XB := X;
  60.           YB := Y;
  61.           IF XS > XB THEN
  62.              BEGIN
  63.                T := XS;
  64.                XS := XB;
  65.                XB := T;
  66.              END;
  67.           IF YS > YB THEN
  68.              BEGIN
  69.                T := YS;
  70.                YS := YB;
  71.                YB := T;
  72.              END;
  73.            FOR K := 1 TO OBJPTR-1 DO
  74.             WITH DRAWARY[K] DO
  75.              BEGIN
  76.                OBJSEL := 0;
  77.                CASE OBJTYP OF
  78.             0: BEGIN   END;                            (*  DEL. OBJ. *)
  79.             1: IF (X1 >= XS) AND (X1 <= XB) AND (Y1 >= YS) AND (Y1 <= YB) THEN
  80.                   OBJSEL := 1;                         (*  POINT  *)
  81.             2: BEGIN                                   (*  LINE   *)
  82.                IF (X1 >= XS) AND (X1 <= XB) AND (Y1 >= YS) AND (Y1 <= YB) THEN
  83.                   OBJSEL := 1;
  84.                IF (X2 >= XS) AND (X2 <= XB) AND (Y2 >= YS) AND (Y2 <= YB) THEN
  85.                   OBJSEL := 1;
  86.                END;
  87.             3: BEGIN                                   (*  BOX    *)
  88.                X4 := X3 - X2 + X1;
  89.                Y4 := Y3 - Y2 + Y1;
  90.                IF (X1 >= XS) AND (X1 <= XB) AND (Y1 >= YS) AND (Y1 <= YB) THEN
  91.                   OBJSEL := 1;
  92.                IF (X2 >= XS) AND (X2 <= XB) AND (Y2 >= YS) AND (Y2 <= YB) THEN
  93.                   OBJSEL := 1;
  94.                IF (X3 >= XS) AND (X3 <= XB) AND (Y3 >= YS) AND (Y3 <= YB) THEN
  95.                   OBJSEL := 1;
  96.                IF (X4 >= XS) AND (X4 <= XB) AND (Y4 >= YS) AND (Y4 <= YB) THEN
  97.                   OBJSEL := 1;
  98.                END;
  99.             4: IF (X1 >= XS) AND (X1 <= XB) AND (Y1 >= YS) AND (Y1 <= YB) THEN
  100.                   OBJSEL := 1;                         (*  CIRCLE *)
  101.               END; (* CASE *)
  102.               IF OBJSEL = 1 THEN KODE := 0;
  103.              END; (*WITH*)
  104.         END;
  105.   END; (*PROC*)
  106.